PC go! 2008 April/PCgo 2008-04 (DVD).iso/interface/contents/demoversionen_3846/13664/files/Data1.cab/turbocadtest6.vbs

Text File | 2001-10-16 | 13.6 KB | 607 lines

Option Explicit

Const imsiPolyline = 11
Const imsi3DMesh = 3

Dim tcApp
Dim tcDwgs
Dim tcDwg
Dim tcGrs
Dim tcVw

Dim fso
Dim f
Dim fName
Dim rootPath

Dim bSolid

Sub DumpProp(tcProp)

   f.WriteLine tcProp.Name + " " + CStr(tcProp.Value)

end sub

Sub DumpProps(tcProps)

Dim tcPropType
Dim tcProp
Dim idProp
Dim bNew

   On Error Resume Next
   Set tcPropType = tcProps("RegenMethod")
   fName = rootPath & "\" & tcPropType.Value & ".txt"

   bNew = fso.FileExists(fName)
   Set f = fso.OpenTextFile(fName, 8, True)
   if (Err.Number <> 0) then
        MsgBox Err.Description
        Exit Sub
   end if

   if (Not bNew) then
       f.WriteLine tcPropType.Value
   else
       f.WriteLine ""
   end if

   for each tcProp in tcProps
       idProp = tcProp.ID
       if (Err.Number <> 0) then

           DumpProp tcProp

       end if
   next

   f.Close

end sub

Sub CreateMesh()

Dim tcGrMesh
Dim tcPropsMesh
Dim tcVrtsMesh
Dim cx
Dim cy
Dim dx
Dim dy
Dim dz
Dim x
Dim y
Dim z
Dim indX
Dim indY

    cx = 9
    cy = 9
    dx = 1
    dy = 1

    ' add the cube graphic
    Set tcGrMesh = tcGrs.Add(imsi3DMesh, "TCW70MESH")

    ' add points as verices that will define the box
    Set tcVrtsMesh = tcGrMesh.Vertices

    x = 0
    y = 0
    z = 0

    Randomize
    With tcVrtsMesh
        for indY = 0 to cy
            for indX = 0 to cx
                .Add x, y, z, true, true, true, true
                z = 0 '21 * Rnd - 10
                x = x + dx
            next
            x = 0
            y = y + dy
        next
    End With

    tcGrMesh.Draw
    'DumpProps tcPropsMesh

    Set tcPropsMesh = Nothing
    Set tcVrtsMesh = Nothing
    Set tcGrMesh = Nothing

End Sub

Sub CreateCube()

Dim tcGrCube
Dim tcPropsCube
Dim tcVrtsCube

    ' add the cube graphic
    Set tcGrCube = tcGrs.Add(, "TCW40CUBE")

   ' it is need to set property to make correct graphic
    Set tcPropsCube = tcGrCube.Properties
    with tcPropsCube
        .Item("Solid") = bSolid
    end with

    ' add points as verices that will define the box
    Set tcVrtsCube = tcGrCube.Vertices
    With tcVrtsCube
        .Add 1, 1, 0
        .Add 2, 1, 0
        .Add 1, 2, 0
        .Add 1, 2, 1
    End With

    tcGrCube.Draw
    DumpProps tcPropsCube

    Set tcPropsCube = Nothing
    Set tcVrtsCube = Nothing
    Set tcGrCube = Nothing

End Sub


Sub CreateCone()

Dim tcGrCone
Dim tcGrsCone
Dim tcPropsCone
Dim tcGr1
Dim tcGr2
Dim tcVrts

    ' create the circle graphic that will be
    ' a profile (base) for Cone
    Set tcGr1 = tcGrs.AddCircleCenterAndPoint(1, 1, 0, 2, 2, 0)

   ' add the point graphic
   ' that will be vertex of cone
    Set tcGr2 = tcGrs.Add(imsiPolyline)
    tcGr2.Vertices.Add 1, 1, 4

   ' add the graphic of type TCW40LOFT
   ' that will be a Cone
    Set tcGrCone = tcGrs.Add(, "TCW40LOFT")

   ' it is need to set property to make correct graphic
    Set tcPropsCone = tcGrCone.Properties
    with tcPropsCone
        .Item("Solid") = bSolid
        .Item("$SMOOTH") = 0
    end with

   ' add the point as vertex that
   ' that will be a projection vertex
   ' of cone on base graphic plane
    tcGrCone.Vertices.Add 1, 1, 0

   ' add the profile grahics to graphics collection of cone
    Set tcGrsCone = tcGrCone.Graphics
    tcGrs.Remove(tcGr1.Index)    ' *
    tcGrs.Remove(tcGr2.Index)    ' *

    with tcGrsCone
        .AddGraphic tcGr1
        .AddGraphic tcGr2
    end with

    tcGrCone.Draw
    DumpProps tcPropsCone

    Set tcGr1 = Nothing
    Set tcGr2 = Nothing

    Set tcGrsCone = Nothing
    Set tcPropsCone = Nothing
    Set tcGrCone = Nothing

End Sub

Public Sub CreatePrizm()

Dim tcGrPrizm
Dim tcGrsPrizm
Dim tcPropsPrizm
Dim tcGr1
Dim tcGr2

   ' create the graphic that will be profile
   ' (first base) for Prizm
   Set tcGr1 = tcGrs.AddLineRectangle(1, 1, 0, 2, 2, 0)

   ' create the graphic that will be profile
   ' (second base) for Prizm
   Set tcGr2 = tcGrs.AddLineRectangle(1.2, 1.2, 0, 1.8, 1.8, 0)
   tcGr2.MoveRelative 0, 0, 2

   ' add the graphic of type TCW40LOFT
   ' that will be a Prizm
   Set tcGrPrizm = tcGrs.Add(, "TCW40LOFT")

   ' it is need to set properties to make correct graphic
    Set tcPropsPrizm = tcGrPrizm.Properties
    With tcPropsPrizm
       .Item("Solid") = bSolid
       .Item("$SMOOTH") = 0
    End With

   ' add the profile grahics to graphics collection of Prizm
    tcGrs.Remove(tcGr1.Index)   ' *
    tcGrs.Remove(tcGr2.Index)   ' *

    Set tcGrsPrizm = tcGrPrizm.Graphics
    With tcGrsPrizm
        .AddGraphic tcGr1
        .AddGraphic tcGr2
    End With

    '? To avoid one bug we now have in TurboCAD
    '? for prizm we should add and them remove a one vertex

    '? Set Ver = Gr.Vertices.Add(0, 0, 0)
    '? Set Ver = Gr.Vertices.Remove(0)

    tcGrPrizm.Draw
    DumpProps tcPropsPrizm

    Set tcGr1 = Nothing
    Set tcGr2 = Nothing

    Set tcGrsPrizm = Nothing
    Set tcPropsPrizm = Nothing
    Set tcGrPrizm = Nothing

End Sub

Sub CreateNormalExtrusion()

Dim tcGrExtrusion
Dim tcPropsExtrusion
Dim tcVrtsExtrusion

Dim tcGr1

    ' create the graphic that will be profile
    ' (base) for Extrusion
    Set tcGr1 = tcGrs.AddLineRectangle(1, 1, 0, 2, 2, 0)

    ' add the graphic of type TCW40EXTRUDE
    ' that will be Extrusion
    Set tcGrExtrusion = tcGrs.Add(, "TCW40EXTRUDE")

   ' it is need to set properties to make correct graphic
    Set tcPropsExtrusion = tcGrExtrusion.Properties
    With tcPropsExtrusion
        .Item("Solid") = bSolid
        .Item("$PIPE") = 1
'       .Item("$APPROCSIMCURVE") = 19
    End With

    ' add the base grahic to graphics collection of Extrusion
    tcGrs.Remove tcGr1.Index ' *
    tcGrExtrusion.Graphics.AddGraphic tcGr1

   ' add points as Vertices to the Extrusionc
   ' to define extrusion path (segment of extrude)
   ' **
   Set tcVrtsExtrusion = tcGrExtrusion.Vertices
   tcVrtsExtrusion.UseWorldCS = True
   With tcVrtsExtrusion
      .Add 1, 1, 0
      .Add 1, 1, 3
   End With

   tcGrExtrusion.Draw
   DumpProps tcPropsExtrusion

   Set tcGr1 = Nothing

   Set tcPropsExtrusion = Nothing
   Set tcVrtsExtrusion = Nothing
   Set tcGrExtrusion = Nothing

End Sub

Sub CreateRigidExtrusion()

Dim x
Dim y
Dim z

Dim tcGrExtrusion
Dim tcPropsExtrusion
Dim tcVrtsExtrusion

Dim tcGr1

    ' create the graphic that will be profile
    ' (base) for extrude
    Set tcGr1 = tcGrs.AddLineRectangle(1, 1, 0, 2, 2, 0)

    ' add the graphic of type TCW40EXTRUDE
    ' that will be Extrusion
    Set tcGrExtrusion = tcGrs.Add(, "TCW40EXTRUDE")

   ' it is need to set properties to make correct graphic
    Set tcPropsExtrusion = tcGrExtrusion.Properties
    With tcPropsExtrusion
        .Item("Solid") = bSolid
        .Item("$PIPE") = 0
'       .Item("$APPROCSIMCURVE") = 19
    End With

    ' add the base grahic to graphics collection of Extrusion
    tcGrs.Remove tcGr1.Index ' *
    tcGrExtrusion.Graphics.AddGraphic tcGr1

   ' add points as Vertices to the Extrusionc
   ' to define extrusion path (segment of extrude)
   ' **
   Set tcVrtsExtrusion = tcGrExtrusion.Vertices
   tcVrtsExtrusion.UseWorldCS = True

   x = 1.5
   y = 1.5
   z = 0

   With tcVrtsExtrusion

       .Add x, y, z
       x = x + 1
       z = z + 1
       .Add x, y, z
       y = y + 1
       .Add x, y, z
       z = z + 1
       .Add x, y, z

   End With

   tcGrExtrusion.Draw
   DumpProps tcPropsExtrusion
   Set tcGr1 = Nothing

   Set tcPropsExtrusion = Nothing
   Set tcVrtsExtrusion = Nothing
   Set tcGrExtrusion = Nothing

End Sub

Sub CreateHemiSphere()

Dim tcGrHemiSphere
Dim tcPropsHemiSphere
Dim tcVrtsHemiSphere

    ' add the graphic of type TCW40SPHERE
    ' that will be HemiSphere
    Set tcGrHemiSphere = tcGrs.Add(, "TCW40SPHERE")

   ' it is need to set properties to make correct graphic
    Set tcPropsHemiSphere = tcGrHemiSphere.Properties
    With tcPropsHemiSphere
       .Item("Solid") = bSolid
       .Item("$HEMISPHERE") = 1
'      .Item("$MERIDIANDENSITY") = 45
'      .Item("$PARALLELDENSITY") = 67
'      .Item("$SMOOTH") = 1
    End With

    Set tcVrtsHemiSphere = tcGrHemiSphere.Vertices
    With tcVrtsHemiSphere
        .Add 1, 1, 1
        .Add -1, -1, 1
    End With

    tcGrHemiSphere.Draw
    DumpProps tcPropsHemiSphere

    Set tcVrtsHemiSphere = Nothing
    Set tcPropsHemiSphere = Nothing

    Set tcGrHemiSphere = Nothing

End Sub

Sub CreateSphere()

Dim tcGrSphere
Dim tcPropsSphere
Dim tcVrtsSphere

    ' add the graphic of type TCW40SPHERE
    ' that will be Sphere
    Set tcGrSphere = tcGrs.Add(, "TCW40SPHERE")

   ' it is need to set properties to make correct graphic
    Set tcPropsSphere = tcGrSphere.Properties
    With tcPropsSphere
       .Item("Solid") = bSolid
       .Item("$HEMISPHERE") = 0
'      .Item("$MERIDIANDENSITY") = 45
'      .Item("$PARALLELDENSITY") = 67
'      .Item("$SMOOTH") = 1
    End With

    Set tcVrtsSphere = tcGrSphere.Vertices
    With tcVrtsSphere
        .Add 1, 1, 1
        .Add -1, -1, 1
    End With

    tcGrSphere.Draw
    DumpProps tcPropsSphere

    Set tcVrtsSphere = Nothing
    Set tcPropsSphere = Nothing

    Set tcGrSphere = Nothing

End Sub

Sub CreateRevolve()

Dim tcGrRevolve
Dim tcPropsRevolve
Dim tcVrtsRevolve

Dim tcGr1

    ' create the graphic that will be profile
    ' (base) for Revolve
    Set tcGr1 = tcGrs.AddLineSingle(0, 0, 0, 0.5, 0, 0)
    tcGr1.Vertices.Add 0.5, 0.5, 0
    tcGr1.Close

    ' create graphic of type TCW40SPIN
    ' that will be Revolve
    Set tcGrRevolve = tcGrs.Add(, "TCW40SPIN")

    ' it is need to set properties to make correct graphic
    Set tcPropsRevolve = tcGrRevolve.Properties
    With tcPropsRevolve
       .Item("Solid") = bSolid
' ?    .Item("$ROTATIONANGLE") = 90
       .Item("$ROTATIONANGLE") = 360
       .Item("$SPIRENUMBER") = 5
       .Item("$STEP") = 1
'      .Item("$APPROCSIMCURVE") = 56
'      .Item("$SMOOTH") = 1
    End with

   ' add the base grahic to graphics collection of Revolve
    tcGrs.Remove tcGr1.Index ' "
    tcGrRevolve.Graphics.AddGraphic tcGr1

    ' add two points to the define Revolve axis
    Set tcVrtsRevolve = tcGrRevolve.Vertices
    tcVrtsRevolve.UseWorldCS = True
    With tcVrtsRevolve
        .Add 1, 1, 0
        .Add 1, 2, 0
    End With

    tcGrRevolve.Draw
    DumpProps tcPropsRevolve

    Set tcGr1 = Nothing

    Set tcPropsRevolve = Nothing
    Set tcVrtsRevolve  = Nothing
    Set tcGrRevolve    = Nothing

End Sub

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set tcApp = CreateObject("TurboCAD.Application")
    rootPath = tcApp.Path

    bSolid = False
    Set tcDwgs = tcApp.Drawings

    if (tcDwgs.Count > 0) then

        Set tcDwg = tcApp.ActiveDrawing
        Set tcVw = tcDwg.ActiveView
        Set tcGrs = tcDwg.Graphics

        CreateCube
        CreateCone
        CreatePrizm
        CreateNormalExtrusion
        CreateRigidExtrusion
        CreateHemiSphere
        CreateSphere
        CreateRevolve

        tcVw.ZoomToExtents
    end if

    MsgBox "Done"

    Set tcDwgs = Nothing
    Set tcApp = Nothing

'******************** Notes *******************************************
'
' * - it is need to remove the Graphic Object from Graphics collection
'     before add to another because Graphic Object can't belongs 2 different
'      Graphics Colloections
'
' ** - extrusion path will be automaticalle recalculated and vill be centered
'      relatively to geometric center of the base extrusion profile
'
'
'==============================================
' TCW40CUBE
'==============================================
' Material                3D Page, Material
' Solid                    3D Page, Solid/Surface

' $ACISCOSMETIC            Not used

'==============================================
' TCW40LOFT
'==============================================
' Material                3D Page, Material
' Solid                    3D Page, Solid/Surface

' $ACISCOSMETIC            Not used
' $SOLID                Not used

' $APPROCSIMCURVE        Lofting Shape Page, Number of approximation lines
' $SMOOTH                Lofting Shape Page, Smooth
' $MINTWIST                Lofting Shape Page, Minimize Twist

'==============================================
' TCW40EXTRUDE
'==============================================
' Material                3D Page, Material
' Solid                    3D Page, Solid/Surface

' $ACISCOSMETIC            Not used
' $SOLID                Not used

' $PIPE                    Local Menu option,  Normal Path
' $APPROCSIMCURVE        Extrude Shape Page, Number of approximation lines
' $SMOOTH                Extrude Shape Page, Smooth
' $TWISTANGLE            Extrude Shape Page, Twist Angle (degrees in UI, but radians for programming)

'==============================================
' "TCW40SPHERE"
'==============================================
'
' Material                3D Page, Material
' Solid                    3D Page, Solid/Surface
'
' $ACISCOSMETIC            not used
'
' $HEMISPHERE            Sphere tool/Hemisphere tool
'
' $PARALLELDENSITY        Sphere Page, Number of latitudinal segments
' $MERIDIANDENSITY        Sphere Page, Number of longitudinal segments
' $SMOOTH                 Sphere Page, Smooth

'==============================================
' TCW40SPIN
'==============================================
' Material                3D Page, Material
' Solid                    3D Page, Solid/Surface
'
' $ACISCOSMETIC            not used
' $SPIRENUMBER            not used

' $ROTATIONCOPY            Sections per spiral coil
' $APPROCSIMCURVE        Number of approximation lines
' $ROTATIONANGLE        Angle of rotation (degrees in UI, but radians for programming)
' $SMOOTH                Smooth
' $STEP                    Spiral pitch
' $HANDINESS            Counterclockwise/Clockwise
' $COILNUMBER            Number of coils